home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / arch.scm next >
Text File  |  1995-10-13  |  9KB  |  264 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file arch.scm.
  6.  
  7. ;;;; Architecture description
  8.  
  9. ; Things that the VM and the runtime system both need to know.
  10.  
  11. (define bits-used-per-byte 8)
  12.  
  13. ; Maximum number of arguments that can be pushed on the stack to make a call,
  14. ; also the maximum number of arguments + temporaries allowed on the stack.
  15. (define maximum-stack-args 63)
  16.  
  17. ; Bytecodes: for compiler and interpreter
  18.  
  19. ; Instruction specification is 
  20. ; (op . args)
  21. ; OP may be a name or a list of names
  22. ; ARGS are
  23. ;  nargs     - a byte
  24. ;  byte      - a byte
  25. ;  index     - a byte indexing into the current template
  26. ;  offset    - two bytes giving an offset into the current instruction stream
  27. ;  stob      - a byte specifying a type for a stored object
  28. ;  0 1 2 ... - the number of non-instruction-stream arguments (some
  29. ;              instructions take a variable number of arguments; the first
  30. ;              number is the argument count implemented by the VM)
  31. ;  +         - any number of additional arguments are allowed
  32.  
  33. (define-syntax define-instruction-set
  34.   (lambda (form rename compare)
  35.     (let ((data (do ((data (reverse (cdr form)) (cdr data))
  36.                      (new '() (let ((next (car data)))
  37.                                 (if (pair? (car next))
  38.                                     (append (map (lambda (op)
  39.                                                    (cons op (cdr next)))
  40.                                                  (car next))
  41.                                             new)
  42.                                     (cons next new)))))
  43.                     ((null? data) new))))
  44.       `(begin (define-enumeration op
  45.                 ,(map car data))
  46.               (define opcode-arg-specs
  47.                 '#(,@(map cdr data)))))))
  48.  
  49. (define-instruction-set
  50.   (check-nargs=   nargs)         ; error if *nargs* not= operand
  51.   (check-nargs>=  nargs)         ; error if *nargs* < operand
  52.   (nargs)                        ; move *nargs* to *val*
  53.   (make-env       nargs)         ; cons an environment
  54.   (make-heap-env  nargs)         ; cons an environment in the heap
  55.   (pop-env)                      ; use superior env
  56.   (make-rest-list nargs +)       ; pop all but nargs things off the stack
  57.                                  ; into a list
  58.   (literal        index)         ; value to *val*
  59.   (local          byte byte)     ; back and over
  60.   ((local0 local1 local2)
  61.    byte)                         ; back encoded into op-code for efficiency
  62.   (set-local!     byte byte 1)   ; back over value
  63.   (global         index)         ; value to *val*
  64.   (set-global!    index 1)
  65.   (closure        index)         ; use environment in *env*
  66.   (push 1)                       ; push *val* onto stack
  67.   (pop)                          ; pop top of stack into *val*
  68.   (stack-ref      byte)          ; index'th element of stack into *val*
  69.   (stack-set!     byte 1)        ; *val* to index'th element of stack
  70.  
  71.   (make-cont      offset nargs)  ; save state in *cont*
  72.   (current-cont)                 ; copy *cont* to *val*, use WITH-CONTINUATION
  73.                                  ; to use copied continuation
  74.   (get-cont-from-heap)           ; copy next continuation from heap (this
  75.                                  ; op-code is used internally by the VM)
  76.  
  77.   ;; five different ways to call procedures
  78.   (call               nargs 1 +) ; last argument is the procedure to call
  79.   (move-args-and-call nargs 1 +) ; same, move args to just above *cont* first
  80.   (apply              nargs 1 +) ; last argument is a list of additional 
  81.                                  ; arguments, second to last is procedure to
  82.                                  ; call
  83.   (with-continuation          2) ; first arg is cont, second is procedure
  84.   (call-with-values           +) ; values are on stack, consumer is in the
  85.                                  ; continuation pointed to by *cont*
  86.  
  87.   ;; Three different ways to return from calls and one way to ignore any
  88.   ;; returned values
  89.   (return 1)                     ; return to continuation in *cont*
  90.   (values +)                     ; values are on stack, count is in *nargs*
  91.   (return-values nargs +)        ; values are on stack, count is next byte
  92.   (ignore-values +)              ; ignore (and dispose of) returned values
  93.  
  94.   ;; Five different ways to jump
  95.   (goto-template        index)   ; jump to another template
  96.                                  ; does not poll for interrupts
  97.   (call-template  nargs index)   ; call a template instead of a procedure
  98.                                  ; nargs is needed for interrupt handling
  99.   (jump-if-false  offset 1)      ; boolean in *val*
  100.   (jump           offset)
  101.   (computed-goto  byte offset 1) ; jump using delta specified by *val*
  102.                                  ; default to instruction after deltas
  103.  
  104.  
  105.   ;; Scalar primitives
  106.   (eq? 2)
  107.  
  108.   ((number? integer? rational? real? complex? exact?) 1)
  109.   ((exact->inexact inexact->exact) 1)
  110.  
  111.   ((+ *) 2 0 1 +)
  112.   ((- /) 2 1)
  113.   ((= <) 2 +)
  114.   ((quotient remainder) 2)
  115.   ((floor numerator denominator
  116.      real-part imag-part
  117.      exp log sin cos tan asin acos sqrt
  118.      angle magnitude)
  119.    1)
  120.   (atan 2)
  121.   ((make-polar make-rectangular) 2)
  122.   (bitwise-not 1)
  123.   ((bitwise-and bitwise-ior bitwise-xor) 2)
  124.   (arithmetic-shift 2)
  125.   (char? 1)
  126.   ((char=? char<?) 2)
  127.   ((char->ascii ascii->char) 1)
  128.   (eof-object? 1)
  129.  
  130.   ;; Data manipulation
  131.   (stored-object-has-type? stob 1)
  132.   (stored-object-length stob 1)
  133.  
  134.   (make-stored-object byte stob)
  135.   (stored-object-ref  stob byte 1) ; byte is the offset
  136.   (stored-object-set! stob byte 2)
  137.  
  138.   (make-vector-object stob 2)         ; size + init
  139.   (stored-object-indexed-ref  stob 2) ; vector + offset
  140.   (stored-object-indexed-set! stob 3) ; vector + offset + value
  141.  
  142.   (make-code-vector 2)
  143.   (code-vector-length 1)
  144.   (code-vector-ref 2)
  145.   (code-vector-set! 3)
  146.  
  147.   (make-string 2)
  148.   (string-length 1)
  149.   (string-ref 2)
  150.   (string-set! 3)
  151.  
  152.   (location-defined? 1)
  153.   (set-location-defined?! 2)
  154.   ((immutable? make-immutable!) 1)
  155.  
  156.   ;; I/O
  157.   (open-port 2)
  158.   ((close-port input-port? output-port?) 1)
  159.   ((read-char peek-char char-ready?) 1 0)
  160.   (write-char 2 1)
  161.   (write-string 2)
  162.   (force-output 1)
  163.  
  164.   ;; Misc
  165.   ((unassigned unspecific))
  166.   (trap 1)                      ; raise exception specified by argument
  167.   (false)                       ; return #f (for bootstrapping)
  168.   (write-image 3)
  169.   (collect)
  170.   (memory-status 2)
  171.   (find-all-symbols 1)          ; puts the symbols in a table
  172.   (find-all-xs 1)               ; returns a vector containing all Xs
  173.   (get-dynamic-state)
  174.   (set-dynamic-state! 1)
  175.   (set-exception-handler! 1)
  176.   (set-interrupt-handlers! 1)
  177.   (set-enabled-interrupts! 1)
  178.   (return-from-interrupt)
  179.   (schedule-interrupt 1)
  180.   (external-lookup 1)
  181.   (external-call 1 +)
  182.   (time 2)
  183.   (vm-extension 2)              ; access to extensions of the virtual machine
  184.   (vm-return 2)                 ; return from the vm in a restartable fashion
  185.  
  186.   ;; Unnecessary primitives
  187.   (string=? 2)
  188.   (string-hash 1)
  189.   (reverse-list->string 2)
  190.   (intern 2)
  191.   )
  192.  
  193. (define-enumeration interrupt
  194.   (alarm       ; order matters - higher priority first
  195.    keyboard
  196.    memory-shortage
  197.    ))
  198.  
  199. ; Options for op/time
  200.  
  201. (define-enumeration time-option
  202.   (ticks-per-second
  203.    run-time
  204.    real-time
  205.    ))
  206.  
  207. ; Options for op/memory-status
  208.  
  209. (define-enumeration memory-status-option
  210.   (available
  211.    heap-size
  212.    stack-size
  213.    set-minimum-recovered-space!
  214.    gc-count
  215.    ))
  216.  
  217. (define-enumeration stob
  218.   (;; D-vector types (traced by GC)
  219.    pair
  220.    symbol
  221.    vector
  222.    closure
  223.    location
  224.    port
  225.    ratio
  226.    record
  227.    continuation
  228.    extended-number
  229.    template
  230.    weak-pointer
  231.    external
  232.    unused-d-header1
  233.    unused-d-header2
  234.  
  235.    ;; B-vector types (not traced by GC)
  236.    string        ; = least b-vector type
  237.    code-vector
  238.    double        ; double precision floating point
  239.    bignum
  240.    ))
  241.  
  242. ; This is here to try to ensure that it is changed when STOB changes.
  243. (define least-b-vector-type (enum stob string))
  244.  
  245. ; (stob predicate constructor . (accessor modifier)*)
  246. ; If nothing else, the run-time system and the VM need to agree on
  247. ; which slot of a pair is the car and which is the cdr.
  248.  
  249. (define stob-data
  250.   '((pair pair? cons
  251.       (car set-car!) (cdr set-cdr!))
  252.     (symbol symbol? make-symbol       ; symbols actually made using op/intern
  253.       (symbol->string #f))
  254.     (location location? make-location
  255.       (contents set-contents!) (location-id set-location-id!))
  256.     (closure closure? make-closure
  257.       (closure-template #f) (closure-env #f))
  258.     (weak-pointer weak-pointer? make-weak-pointer
  259.       (weak-pointer-ref #f))
  260.     (external external? make-external
  261.       (external-name #f) (external-value #f))
  262.     ))
  263.  
  264.